home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / dumpvar.pl < prev    next >
Encoding:
Perl Script  |  1999-12-28  |  10.4 KB  |  391 lines
  1. require 5.002;            # For (defined ref)
  2. package dumpvar;
  3.  
  4.  
  5.  
  6.  
  7.  
  8.  
  9. $winsize = 80 unless defined $winsize;
  10.  
  11.  
  12.  
  13. $printUndef = 1 unless defined $printUndef;
  14. $tick = "auto" unless defined $tick;
  15. $unctrl = 'quote' unless defined $unctrl;
  16. $subdump = 1;
  17.  
  18. sub main::dumpValue {
  19.   local %address;
  20.   local $^W=0;
  21.   (print "undef\n"), return unless defined $_[0];
  22.   (print &stringify($_[0]), "\n"), return unless ref $_[0];
  23.   dumpvar::unwrap($_[0],0);
  24. }
  25.  
  26.  
  27. sub unctrl {
  28.     local($_) = @_;
  29.     local($v) ; 
  30.  
  31.     return \$_ if ref \$_ eq "GLOB";
  32.     s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  33.     $_;
  34. }
  35.  
  36. sub stringify {
  37.     local($_,$noticks) = @_;
  38.     local($v) ; 
  39.     my $tick = $tick;
  40.  
  41.     return 'undef' unless defined $_ or not $printUndef;
  42.     return $_ . "" if ref \$_ eq 'GLOB';
  43.     if ($tick eq 'auto') {
  44.       if (/[\000-\011\013-\037\177]/) {
  45.         $tick = '"';
  46.       }else {
  47.         $tick = "'";
  48.       }
  49.     }
  50.     if ($tick eq "'") {
  51.       s/([\'\\])/\\$1/g;
  52.     } elsif ($unctrl eq 'unctrl') {
  53.       s/([\"\\])/\\$1/g ;
  54.       s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  55.       s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg 
  56.         if $quoteHighBit;
  57.     } elsif ($unctrl eq 'quote') {
  58.       s/([\"\\\$\@])/\\$1/g if $tick eq '"';
  59.       s/\033/\\e/g;
  60.       s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
  61.     }
  62.     s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
  63.     ($noticks || /^\d+(\.\d*)?\Z/) 
  64.       ? $_ 
  65.       : $tick . $_ . $tick;
  66. }
  67.  
  68. sub ShortArray {
  69.   my $tArrayDepth = $#{$_[0]} ; 
  70.   $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1 
  71.     unless  $arrayDepth eq '' ; 
  72.   my $shortmore = "";
  73.   $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
  74.   if (!grep(ref $_, @{$_[0]})) {
  75.     $short = "0..$#{$_[0]}  '" . 
  76.       join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
  77.     return $short if length $short <= $compactDump;
  78.   }
  79.   undef;
  80. }
  81.  
  82. sub DumpElem {
  83.   my $short = &stringify($_[0], ref $_[0]);
  84.   if ($veryCompact && ref $_[0]
  85.       && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
  86.     my $end = "0..$#{$v}  '" . 
  87.       join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
  88.   } elsif ($veryCompact && ref $_[0]
  89.       && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
  90.     my $end = 1;
  91.       $short = $sp . "0..$#{$v}  '" . 
  92.         join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
  93.   } else {
  94.     print "$short\n";
  95.     unwrap($_[0],$_[1]);
  96.   }
  97. }
  98.  
  99. sub unwrap {
  100.     return if $DB::signal;
  101.     local($v) = shift ; 
  102.     local($s) = shift ; # extra no of spaces
  103.     local(%v,@v,$sp,$value,$key,$type,@sortKeys,$more,$shortmore,$short) ;
  104.     local($tHashDepth,$tArrayDepth) ;
  105.  
  106.     $sp = " " x $s ;
  107.     $s += 3 ; 
  108.  
  109.     if (ref $v) { 
  110.       ($address) = $v =~ /(0x[0-9a-f]+)\)$/ ; 
  111.       if (defined $address) { 
  112.     ($type) = $v =~ /=(.*?)\([^=]+$/ ;
  113.     $address{$address}++ ;
  114.     if ( $address{$address} > 1 ) { 
  115.       print "${sp}-> REUSED_ADDRESS\n" ; 
  116.       return ; 
  117.     } 
  118.       }
  119.     } elsif (ref \$v eq 'GLOB') {
  120.       $address = "$v" . "";    # To avoid a bug with globs
  121.       $address{$address}++ ;
  122.       if ( $address{$address} > 1 ) { 
  123.     print "${sp}*DUMPED_GLOB*\n" ; 
  124.     return ; 
  125.       } 
  126.     }
  127.  
  128.     if ( UNIVERSAL::isa($v, 'HASH') ) { 
  129.     @sortKeys = sort keys(%$v) ;
  130.     undef $more ; 
  131.     $tHashDepth = $#sortKeys ; 
  132.     $tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
  133.       unless $hashDepth eq '' ; 
  134.     $more = "....\n" if $tHashDepth < $#sortKeys ; 
  135.     $shortmore = "";
  136.     $shortmore = ", ..." if $tHashDepth < $#sortKeys ; 
  137.     $#sortKeys = $tHashDepth ; 
  138.     if ($compactDump && !grep(ref $_, values %{$v})) {
  139.       $short = $sp;
  140.       my @keys;
  141.       for (@sortKeys) {
  142.         push @keys, &stringify($_) . " => " . &stringify($v->{$_});
  143.       }
  144.       $short .= join ', ', @keys;
  145.       $short .= $shortmore;
  146.       (print "$short\n"), return if length $short <= $compactDump;
  147.     }
  148.     for $key (@sortKeys) {
  149.         return if $DB::signal;
  150.         $value = $ {$v}{$key} ;
  151.         print "$sp", &stringify($key), " => ";
  152.         DumpElem $value, $s;
  153.     }
  154.     print "$sp  empty hash\n" unless @sortKeys;
  155.     print "$sp$more" if defined $more ;
  156.     } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) { 
  157.     $tArrayDepth = $#{$v} ; 
  158.     undef $more ; 
  159.     $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 
  160.       unless  $arrayDepth eq '' ; 
  161.     $more = "....\n" if $tArrayDepth < $#{$v} ; 
  162.     $shortmore = "";
  163.     $shortmore = " ..." if $tArrayDepth < $#{$v} ;
  164.     if ($compactDump && !grep(ref $_, @{$v})) {
  165.       if ($#$v >= 0) {
  166.         $short = $sp . "0..$#{$v}  " . 
  167.           join(" ", 
  168.            map {stringify $_} @{$v}[0..$tArrayDepth])
  169.         . "$shortmore";
  170.       } else {
  171.         $short = $sp . "empty array";
  172.       }
  173.       (print "$short\n"), return if length $short <= $compactDump;
  174.     }
  175.     for $num ($[ .. $tArrayDepth) {
  176.         return if $DB::signal;
  177.         print "$sp$num  ";
  178.         DumpElem $v->[$num], $s;
  179.     }
  180.     print "$sp  empty array\n" unless @$v;
  181.     print "$sp$more" if defined $more ;  
  182.     } elsif (  UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) { 
  183.         print "$sp-> ";
  184.         DumpElem $$v, $s;
  185.     } elsif ( UNIVERSAL::isa($v, 'CODE') ) { 
  186.         print "$sp-> ";
  187.         dumpsub (0, $v);
  188.     } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
  189.       print "$sp-> ",&stringify($$v,1),"\n";
  190.       if ($globPrint) {
  191.     $s += 3;
  192.     dumpglob($s, "{$$v}", $$v, 1);
  193.       } elsif (defined ($fileno = fileno($v))) {
  194.     print( (' ' x ($s+3)) .  "FileHandle({$$v}) => fileno($fileno)\n" );
  195.       }
  196.     } elsif (ref \$v eq 'GLOB') {
  197.       if ($globPrint) {
  198.     dumpglob($s, "{$v}", $v, 1) if $globPrint;
  199.       } elsif (defined ($fileno = fileno(\$v))) {
  200.     print( (' ' x $s) .  "FileHandle({$v}) => fileno($fileno)\n" );
  201.       }
  202.     }
  203. }
  204.  
  205. sub matchvar {
  206.   $_[0] eq $_[1] or 
  207.     ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and 
  208.       ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
  209. }
  210.  
  211. sub compactDump {
  212.   $compactDump = shift if @_;
  213.   $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
  214.   $compactDump;
  215. }
  216.  
  217. sub veryCompact {
  218.   $veryCompact = shift if @_;
  219.   compactDump(1) if !$compactDump and $veryCompact;
  220.   $veryCompact;
  221. }
  222.  
  223. sub unctrlSet {
  224.   if (@_) {
  225.     my $in = shift;
  226.     if ($in eq 'unctrl' or $in eq 'quote') {
  227.       $unctrl = $in;
  228.     } else {
  229.       print "Unknown value for `unctrl'.\n";
  230.     }
  231.   }
  232.   $unctrl;
  233. }
  234.  
  235. sub quote {
  236.   if (@_ and $_[0] eq '"') {
  237.     $tick = '"';
  238.     $unctrl = 'quote';
  239.   } elsif (@_ and $_[0] eq 'auto') {
  240.     $tick = 'auto';
  241.     $unctrl = 'quote';
  242.   } elsif (@_) {        # Need to set
  243.     $tick = "'";
  244.     $unctrl = 'unctrl';
  245.   }
  246.   $tick;
  247. }
  248.  
  249. sub dumpglob {
  250.     return if $DB::signal;
  251.     my ($off,$key, $val, $all) = @_;
  252.     local(*entry) = $val;
  253.     my $fileno;
  254.     if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
  255.       print( (' ' x $off) . "\$", &unctrl($key), " = " );
  256.       DumpElem $entry, 3+$off;
  257.     }
  258.     if (($key !~ /^_</ or $dumpDBFiles) and defined @entry) {
  259.       print( (' ' x $off) . "\@$key = (\n" );
  260.       unwrap(\@entry,3+$off) ;
  261.       print( (' ' x $off) .  ")\n" );
  262.     }
  263.     if ($key ne "main::" && $key ne "DB::" && defined %entry
  264.     && ($dumpPackages or $key !~ /::$/)
  265.     && ($key !~ /^_</ or $dumpDBFiles)
  266.     && !($package eq "dumpvar" and $key eq "stab")) {
  267.       print( (' ' x $off) . "\%$key = (\n" );
  268.       unwrap(\%entry,3+$off) ;
  269.       print( (' ' x $off) .  ")\n" );
  270.     }
  271.     if (defined ($fileno = fileno(*entry))) {
  272.       print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
  273.     }
  274.     if ($all) {
  275.       if (defined &entry) {
  276.     dumpsub($off, $key);
  277.       }
  278.     }
  279. }
  280.  
  281. sub dumpsub {
  282.     my ($off,$sub) = @_;
  283.     $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
  284.     my $subref = \&$sub;
  285.     my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
  286.       || ($subdump && ($sub = findsubs("$subref")) && $DB::sub{$sub});
  287.     $place = '???' unless defined $place;
  288.     print( (' ' x $off) .  "&$sub in $place\n" );
  289. }
  290.  
  291. sub findsubs {
  292.   return undef unless defined %DB::sub;
  293.   my ($addr, $name, $loc);
  294.   while (($name, $loc) = each %DB::sub) {
  295.     $addr = \&$name;
  296.     $subs{"$addr"} = $name;
  297.   }
  298.   $subdump = 0;
  299.   $subs{ shift() };
  300. }
  301.  
  302. sub main::dumpvar {
  303.     my ($package,@vars) = @_;
  304.     local(%address,$key,$val,$^W);
  305.     $package .= "::" unless $package =~ /::$/;
  306.     *stab = *{"main::"};
  307.     while ($package =~ /(\w+?::)/g){
  308.       *stab = $ {stab}{$1};
  309.     }
  310.     local $TotalStrings = 0;
  311.     local $Strings = 0;
  312.     local $CompleteTotal = 0;
  313.     while (($key,$val) = each(%stab)) {
  314.       return if $DB::signal;
  315.       next if @vars && !grep( matchvar($key, $_), @vars );
  316.       if ($usageOnly) {
  317.     globUsage(\$val, $key) unless $package eq 'dumpvar' and $key eq 'stab';
  318.       } else {
  319.     dumpglob(0,$key, $val);
  320.       }
  321.     }
  322.     if ($usageOnly) {
  323.       print "String space: $TotalStrings bytes in $Strings strings.\n";
  324.       $CompleteTotal += $TotalStrings;
  325.       print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
  326.     }
  327. }
  328.  
  329. sub scalarUsage {
  330.   my $size = length($_[0]);
  331.   $TotalStrings += $size;
  332.   $Strings++;
  333.   $size;
  334. }
  335.  
  336. sub arrayUsage {        # array ref, name
  337.   my $size = 0;
  338.   map {$size += scalarUsage($_)} @{$_[0]};
  339.   my $len = @{$_[0]};
  340.   print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
  341.     " (data: $size bytes)\n"
  342.       if defined $_[1];
  343.   $CompleteTotal +=  $size;
  344.   $size;
  345. }
  346.  
  347. sub hashUsage {        # hash ref, name
  348.   my @keys = keys %{$_[0]};
  349.   my @values = values %{$_[0]};
  350.   my $keys = arrayUsage \@keys;
  351.   my $values = arrayUsage \@values;
  352.   my $len = @keys;
  353.   my $total = $keys + $values;
  354.   print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
  355.     " (keys: $keys; values: $values; total: $total bytes)\n"
  356.       if defined $_[1];
  357.   $total;
  358. }
  359.  
  360. sub globUsage {            # glob ref, name
  361.   local *name = *{$_[0]};
  362.   $total = 0;
  363.   $total += scalarUsage $name if defined $name;
  364.   $total += arrayUsage \@name, $_[1] if defined @name;
  365.   $total += hashUsage \%name, $_[1] if defined %name and $_[1] ne "main::" 
  366.     and $_[1] ne "DB::";   #and !($package eq "dumpvar" and $key eq "stab"));
  367.   $total;
  368. }
  369.  
  370. sub packageUsage {
  371.   my ($package,@vars) = @_;
  372.   $package .= "::" unless $package =~ /::$/;
  373.   local *stab = *{"main::"};
  374.   while ($package =~ /(\w+?::)/g){
  375.     *stab = $ {stab}{$1};
  376.   }
  377.   local $TotalStrings = 0;
  378.   local $CompleteTotal = 0;
  379.   my ($key,$val);
  380.   while (($key,$val) = each(%stab)) {
  381.     next if @vars && !grep($key eq $_,@vars);
  382.     globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
  383.   }
  384.   print "String space: $TotalStrings.\n";
  385.   $CompleteTotal += $TotalStrings;
  386.   print "\nGrand total = $CompleteTotal bytes\n";
  387. }
  388.  
  389. 1;
  390.  
  391.